#!/bin/sh
# -*- scheme -*-
prefix="/usr/local"
exec_prefix="${prefix}"
exec ${GUILE:-${exec_prefix}/bin/guile} $GUILE_FLAGS -e '(@@ (protoc-scm) main)' -s "$0" "$@"
!#

;;;; protoc-scm --- Code generation utility for r6rs-protobuf/Guile
;;;; 
;;;; 	Copyright (C) 2013 Julian Graham.
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(define-module (protoc-scm)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 command-line)
  #:use-module (ice-9 pretty-print)
  #:use-module (ice-9 receive)
  #:use-module (protobuf compile)
  #:use-module (protobuf compile parse)
  #:use-module (protobuf protobuf)
  #:use-module (rnrs hashtables)
  #:use-module (rnrs io simple)
  #:use-module (srfi srfi-1))

(define *option-grammar*
  '((help (single-char #\h))
    (proto_path (single-char #\I))
    (scm_out (value #t))
    (version)))

(define (display-version)
  (format (current-output-port) "(protobuf protobuf) ~A" (protobuf:version))
  (newline))

(define (display-help)
  (display "Usage: protoc-scm [OPTION] PROTO_FILES") (newline)
  (display "Parse PROTO_FILES and generate output based on the options given:")
  (newline)

  (display 

"  -IPATH, --proto_path=PATH   Specify the directory in which to search for
                              imports.  May be specified multiple times;
                              directories will be searched in order.  If not
                              given, the current working directory is used.
  --version                   Show version info and exit.
  -h, --help                  Show this text and exit.
  --scm_out=OUT_DIR           Generate SCM files.")
  (newline))

(define (mkdirs root dir-list)
  (or (file-exists? root)
      (raise (make-i/o-file-does-not-exist-error root)))
  (or (null? dir-list)
      (let loop ((root (string-append root "/" (car dir-list)))
		 (dir-list (cdr dir-list)))
	(catch 'system-error
	  (lambda () (mkdir root))
	  (lambda ex
	    (let ((errno (system-error-errno ex)))
	      (if (not (= errno EEXIST))
		  (begin (display (strerror errno)) 
			 (newline) 
			 (exit 1))))))
	(or (null? dir-list)
	    (loop (string-append root "/" (car dir-list))
		  (cdr dir-list))))))

(define (write-library output-root library)
  (let* ((full-name (map symbol->string (cadr library)))
	 (parent (drop-right full-name 1))
	 (filename (car (take-right full-name 1))))
    
    (mkdirs output-root parent)
    (let ((port (open-file
		 (string-append output-root "/" 
				(string-join parent "/") "/" 
				filename ".scm")
		 "w")))

      (display 
       ";; Generated by the protocol buffer compiler.  DO NOT EDIT!" port)
      (newline port) (newline port)

      (display "#!r6rs" port) (newline port) (newline port)
      (pretty-print library port))))

(define (main args)
  (if (defined? 'setlocale)
      (setlocale LC_ALL ""))

  (let* ((options (getopt-long args *option-grammar*
                               #:stop-at-first-non-option #t))
         (args (option-ref options '() '())))
    (cond 
     ((option-ref options 'version #f) (display-version) (exit 0))
     ((option-ref options 'help #f) (display-help) (exit 0)))
    
    (let ((output-root (option-ref options 'scm_out #f)))
      (or output-root
	  (begin (display "Missing output directives.") 
		 (newline) 
		 (exit 1)))
      
      (for-each (lambda (arg)
		  (let ((proto (protoc:read-proto (open-input-file arg))))
		    (receive libraries 
		      (protoc:generate-libraries proto (dirname arg))
		      (for-each (lambda (library) 
				  (write-library output-root library))
				libraries))))
		args))
    (exit 0)))
